home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Libs / CSP / forloop.em < prev    next >
Encoding:
Text File  |  1993-07-18  |  3.7 KB  |  169 lines
  1. ;; foreach module 
  2. ;; and other useful stuff
  3. ;; IE. General garbage module.
  4. (defmodule forloop
  5.   (standard) ()
  6.  
  7.   (defmacro foreach (dummy var in list do . forms)
  8.     `(mapc (lambda (,var) ,@forms)
  9.        ,list))
  10.  
  11.   (export foreach)
  12.  
  13.   (defun show (object)
  14.     (mapcar (lambda (slot-name)  (format t "~a: ~a\n" slot-name
  15.                      (slot-value object slot-name)))
  16.         (mapcar slot-description-name
  17.             (class-slot-descriptions (class-of object)))))
  18.  
  19.   (defun rshow (x)
  20.     (rshow-aux x ""))
  21.  
  22.   ;; same, but generic + recursive
  23.   (defun rshow-aux (x st)
  24.     (cond ((> (string-length st) 100)
  25.        (format t "..."))
  26.       (t (generic-rshow x st))))
  27.  
  28.  
  29.   (defgeneric generic-rshow (ob st))
  30.  
  31.   (defmethod generic-rshow ((ob object) string)
  32.     (print ob)
  33.     (mapc (lambda (slot-name)
  34.           (format t "~a ~a:" string slot-name)
  35.           (rshow-aux (slot-value ob slot-name)
  36.              (string-append string "  ")))
  37.       (mapcar slot-description-name 
  38.           (class-slot-descriptions (class-of ob))))
  39.     nil)
  40.  
  41. ;;  (defmethod generic-rshow ((l pair) st)
  42. ;;     (format t "~a List: ~a\n" st (car l))
  43. ;;     (rshow-aux (car l) (string-append st "      "))
  44. ;;     (rshow-aux (cdr l) st))
  45.  
  46.   (defconstant Null (class-of nil))
  47.  
  48. ;;  (defmethod generic-rshow ((a Null) st)
  49. ;;    nil)
  50.           
  51.  
  52.   (export show)
  53.   (export rshow)
  54.   
  55.   (defun nth (n list)
  56.     (cond ((= n 0) (car list))
  57.       (t (nth (- n 1) (cdr list)))))
  58.   (export nth)
  59.  
  60.   (defun length (x)
  61.     (cond ((null x)
  62.        0)
  63.       (t (+ 1 (length (cdr x))))))
  64.  
  65.   (export length)
  66.  
  67.   (defun min-list (x)
  68.     (cond ((null (cdr x)) (car x))
  69.       (t (let ((min-rest (min-list (cdr x))))
  70.            (cond ((< (car x) min-rest)
  71.               (car x))
  72.              (t min-rest))))))
  73.   (export min-list)
  74.           
  75.   (defun minl (x . l)
  76.     (min-aux x l))
  77.  
  78.   (defun min-aux (x l)
  79.     (cond ((null l) x)
  80.       ((< x (car l))
  81.        (min-aux x (cdr l)))
  82.       (t (min-aux (car l) (cdr l)))))
  83.  
  84.   (defun maxl (x . l)
  85.     (max-aux x l))
  86.  
  87.   (defun max-aux (x l)
  88.     (cond ((null l) x)
  89.       ((> x (car l))
  90.        (max-aux x (cdr l)))
  91.       (t (max-aux  (car l) (cdr l)))))
  92.  
  93.  
  94.   (export minl maxl)
  95.  
  96.  
  97.   ;; Useful function not defined EulispLISP
  98.   (defun deleq (a b)
  99.     (cond
  100.      ((null b) nil)
  101.      ((eq a (car b))
  102.       (cdr b))
  103.      (t (cons (car b) (deleq a (cdr b)))) ))
  104.  
  105.   (export deleq)
  106.     
  107.   (defun map-all (fn lst)
  108.     (cond ((null lst) nil)
  109.       ((atom lst) lst)
  110.       ((consp (car lst))
  111.        (cons (map-all fn (car lst))
  112.          (map-all fn (cdr lst))))
  113.       (t (cons (fn (car lst))
  114.            (map-all fn (cdr lst))))))
  115.  
  116.   (export map-all)
  117.  
  118.   (defun fold (fn lst init)
  119.     (cond ((null lst) init)
  120.       (t (fold fn (cdr lst) 
  121.            (fn (car lst) init)))))
  122.   (export fold)
  123.  
  124.   (defun mapvect (fn vect)
  125.     (mapvect-aux fn (vector-length vect) (make-vector (vector-length vect) nil) vect))
  126.  
  127.   ;; work in RL direction (for peversity)
  128.   (defun mapvect-aux (fn i new-v old-v)
  129.     (cond ((zerop i) new-v)
  130.       (t ((setter vector-ref) new-v (- i 1) (fn (vector-ref old-v (- i 1))))
  131.          (mapvect-aux fn (- i 1) new-v old-v))))
  132.  
  133.   (export mapvect)
  134.  
  135.   (defmacro critical-code (dummy sem forms)
  136.     `(progn (open-semaphore sem)
  137.         (let ((result (progn ,@forms)))
  138.           (close-semaphore sem)
  139.           result)))
  140.  
  141.   (export critical-code)
  142.  
  143.   (defun collect (p l)
  144.     (cond ((null l) nil)
  145.       ((p (car l)) (cons (car l)
  146.                  (collect p (cdr l))))
  147.       (t (collect p (cdr l)))))
  148.  
  149.   (export collect)
  150.   ;; Only works  with 'eq' as comparator
  151.   ;; Tidies a table by not copying 'nil' keys
  152. ;  (defmethod copy ((t1 table))
  153. ;    (let ((new-table (make-table eq)))
  154. ;      (mapc (lambda (x) 
  155. ;          (cond ((table-ref t1 x)
  156. ;             ((setter table-ref) new-table x
  157. ;              (table-ref t1 x)))
  158. ;            (t nil)))
  159. ;        (table-keys t1))
  160. ;      new-table))
  161.            
  162. ;;  (defmacro <= (x y)    `(not (> ,x ,y)))
  163.   
  164. ;  (defmacro >= (x y)    `(not (< ,x ,y)))
  165. ;  (export <= >=)
  166.  
  167. ;;end module
  168.   )
  169.